home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / scm / wb1a1.lha / wb / scan.scm < prev    next >
Encoding:
Text File  |  1993-06-29  |  12.5 KB  |  286 lines
  1. ; Wb-tree File Based Associative String Data Base System.
  2. ; Copyright (c) 1991, 1992, 1993 Holland Mark Martin
  3. ;
  4. ;Permission to use, copy, modify, and distribute this software and its
  5. ;documentation for educational, research, and non-profit purposes and
  6. ;without fee is hereby granted, provided that the above copyright
  7. ;notice appear in all copies and that both that copyright notice and
  8. ;this permission notice appear in supporting documentation, and that
  9. ;the name of Holland Mark Martin not be used in advertising or
  10. ;publicity pertaining to distribution of the software without specific,
  11. ;written prior consent in each case.  Permission to incorporate this
  12. ;software into commercial products can be obtained from Jonathan
  13. ;Finger, Holland Mark Martin, 174 Middlesex Turnpike, Burlington, MA,
  14. ;01803-4467, USA.  Holland Mark Martin makes no representations about
  15. ;the suitability or correctness of this software for any purpose.  It
  16. ;is provided "as is" without express or implied warranty.  Holland Mark
  17. ;Martin is under no obligation to provide any services, by way of
  18. ;maintenance, update, or otherwise.
  19.  
  20.  
  21. (require (in-vicinity (program-vicinity) "sys"))
  22.  
  23. ;;; BT-SCAN scans all keys in the range [key1..key2),
  24. ;;; performing one of several functions:
  25. ;;; OPERATION   FUNC       RESULT
  26. ;;; ----------- ---------- -----------------------------------------------
  27. ;;; COUNT-SCAN  NIL        counts all keys in range
  28. ;;; COUNT-SCAN  given      counts all keys in range satisfying FUNC
  29. ;;; REM-SCAN    NIL        deletes all keys in range
  30. ;;; REM-SCAN    given      deletes all keys in range satisfying FUNC
  31. ;;; MODIFY-SCAN NIL        ARGERR
  32. ;;; MODIFY-SCAN given      updates values for keys in range satisfying FUNC
  33. ;;; ----------- ---------- -----------------------------------------------
  34.  
  35. ;;; BT-SCAN returns SUCCESS if scan completed; under any other result code
  36. ;;; the scan is resumable. The possible results are:
  37. ;;;    NOTPRES meaning the blk-limit was exceeded;
  38. ;;;    RETRYERR meaning FUNC or delete got a RETRYERRR;
  39. ;;;    TERMINATED meaning FUNC asked to terminate the scan;
  40. ;;;    <other error> means FUNC or DELETE encountered this errror.
  41. ;;;
  42. ;;; Each block of data is scanned/deleted/modified in a single operation
  43. ;;; that is, the block is found and locked only once, and only written after
  44. ;;; all modifications are made. Tho only exception is that MODIFY-SCANs
  45. ;;; that increase the size of values  can cause block splits. Such cases
  46. ;;; are detected and converted to a PUT plus a NEXT. This has
  47. ;;; two consequences: data is written out each time a PUT occurs,
  48. ;;; and it is conceivable that FUNC may be called more than once on the
  49. ;;; key value that caused the split if a RETRYERR occurs in the PUT.
  50. ;;; However, SCAN guarantees that only one modification will actually be
  51. ;;; made in this case (so that one can write INCREMENT-RANGE, for example).
  52. ;;;
  53. ;;; FUNC is passed pointers to (copies of) the key and value,
  54. ;;; plus one user argument:
  55. ;;;       (FUNC keystr klen vstr vlen extra-arg)
  56. ;;; FUNC is expected to return either: SUCCESS for DELETE/COUNT,
  57. ;;; NOTPRES/NOTDONE for SKIP (ie, DONT DELETE/COUNT), or
  58. ;;; any other code to terminate the scan resumably at the current point.
  59. ;;; For MODIFY-SCAN, if changing the value, the new value length is returned.
  60. ;;; Except for the case mentioned above, the caller can depend on FUNC
  61. ;;; being called exactly once for each key value in the specified range,
  62. ;;; and only on those values.
  63. ;;;
  64. ;;; If key2<=key1 no scan will occur (even if key1 is found).
  65. ;;; To make possible bounded-time operation bt-scan will
  66. ;;; access at most BLK-LIMIT blocks at a time; if you dont care,
  67. ;;; give it -1 for BLK-LIMIT.
  68. ;;;
  69. ;;; The number of keys deleted/counted/modified is returned in the SKEY-COUNT
  70. ;;; field of respkt; the key to resume at is returned in KEY-STR (***which
  71. ;;; therefore needs to be 256 bytes long***); and the new key length
  72. ;;; is returned in SKEY-LEN. If returns SUCCESS, SKEY-LEN is zero.
  73. ;;; NOTE that SKEY-COUNT is cumulative, so the caller need to init it to 0
  74. ;;; when starting a new scan.
  75. ;;;
  76. ;;; ***WARNING*** when BT-SCAN returns other than SUCCESS,
  77. ;;; it MODIFIES the KEY1 string
  78. ;;; so that the string args are correctly set up for the next call
  79. ;;; (the returned value is the new length for KEY1).
  80. ;;; Therefore, KEY-STR MUST BE A MAXIMUM-LENGTH STRING [!!]
  81.  
  82. ;;; changes: 11/12: merged DELETE and SCAN into one;
  83. ;;;                 changed FUNC calling protocol to copy value
  84. ;;;          11/18: fixed bug where SCAN always used ACCWRITE (!oops!)
  85. ;;;                 added MODIFY SCAN
  86. ;;;          12/01: fixed compares on OPERATION to use EQ? instead of =
  87.  
  88. ;;; AGJ - bt-scan modified so that it copies the ent when
  89. ;;; COUNT-SCANning it.  This allows nested SCANs and BTree refs in
  90. ;;; func without contention.
  91.  
  92. (define (bt-scan han operation key-str k-len key2-str k2-len
  93.          func long-tab respkt blk-limit)
  94.   (define pkt (make-vector PKT-SIZE))
  95.   (define opkt (make-vector PKT-SIZE))
  96.   (define ent #f)
  97.   (define vstr (make-string 256))
  98.   (define accmode (if (eq? operation COUNT-SCAN) ACCREAD ACCWRITE))
  99.   (define result SUCCESS)
  100. ;  (fprintf diagout "bt-scan %d:%ld %.*s::%.*s\\n"
  101. ;       (HAN-SEG han) (HAN-ID han)
  102. ;       (max 0 k-len) key-str (max 0 k2-len) key2-str)
  103.   (cond
  104.    ((< k-len -2)
  105.     (fprintf diagout ">>>>ERROR<<<< bt-scan: bad length string1 %d\\n" k-len)
  106.     ARGERR)
  107.    ((< k2-len -1)
  108.     (fprintf diagout ">>>>ERROR<<<< bt-scan: bad length string2 %d\\n" k2-len)
  109.     ARGERR)
  110.    ((and (eq? operation MODIFY-SCAN) (not func))
  111.     (fprintf diagout ">>>>ERROR<<<< bt-scan: MODIFY-SCAN requires func be specified\\n")
  112.     ARGERR)
  113.    (else
  114.     (set! ent (chain-find-ent han accmode key-str k-len pkt))
  115.     (cond
  116.      ((and ent (blk-find-pos (ENT-BLK ent) key2-str k2-len opkt))
  117.       (cond
  118.        ((eq? operation COUNT-SCAN)    ;here we deal with a copy of ent
  119.     (let ((nent (allocate-ent)))    ;to avoid ACCREAD contention.
  120.       (ent-copy! nent ent)
  121.       (release-ent! ent accmode)    ;accmode = ACCREAD here.
  122.       (set! result (chain-scan nent operation pkt opkt key-str
  123.                    func long-tab vstr respkt (HAN-WCB han)))
  124.       (recycle-ent! nent)))
  125.        (else
  126.     (set! result (chain-scan ent operation pkt opkt key-str func long-tab vstr respkt (HAN-WCB han)))
  127.     (release-ent! ent accmode)
  128.     (cond ((> result 0)        ; check for MODIFY special case
  129.            (set! result (bt-put han key-str (SKEY-LEN respkt) vstr result))
  130.            (cond ((= result SUCCESS)
  131.               (SET-SKEY-COUNT! respkt (+ (SKEY-COUNT respkt) 1))
  132.               (SET-SKEY-LEN! respkt (increment-string key-str (SKEY-LEN respkt) 256))
  133.               (set! result NOTPRES)))))))
  134.       (if (and (= result NOTPRES)    ; ie, is there more to do?
  135.            (not (= 0 blk-limit)))
  136.       (bt-scan han operation key-str (SKEY-LEN respkt)
  137.            key2-str k2-len func long-tab respkt (- blk-limit 1))
  138.       result))
  139.      (else
  140.       (if ent (release-ent! ent accmode))
  141.       (set! rem-fct (+ 1 rem-fct))
  142.       UNKERR)))))
  143.  
  144. ;; this function increments a string lexicographically
  145. (define (increment-string str len maxlen)
  146.   (cond ((< len maxlen)
  147.      (string-set! str len (integer->char 0))
  148.      (+ len 1))
  149.     (else
  150.      (let ((oldval (char->integer (string-ref str (- len 1)))))
  151.        (string-set! str (- len 1) (integer->char (+ 1 oldval)))
  152.        len))))
  153.  
  154. ;;; Each call to CHAIN-SCAN scans
  155. ;;; all the keys within the specified range WITHIN block ENT.
  156. ;;; If the scan actually reaches  the end of range, it sets SKEY-LEN=0
  157. ;;; and returns SUCCESS. If there's more to the range,
  158. ;;; it sets KEY-STR to the key to continue deleting
  159. ;;; from (ie, the split key of ENT), SKEY-LEN to its length, and
  160. ;;; returns NOTPRES (NOTDONE). The caller must then call CHAIN-FIND
  161. ;;; to find the START and END keys and call again.
  162.  
  163. (define (chain-scan ent operation pkt opkt key-str func long-tab vstr respkt wcb)
  164.   (let ((blk (ENT-BLK ent))
  165.     (result SUCCESS))
  166.                     ; check for special case of
  167.                                         ; unconditional delete of entire block
  168.     (cond ((and (eq? operation REM-SCAN)
  169.         (not func)
  170.         (> (MATCH-POS opkt) (MATCH-POS pkt))
  171.         (= (MATCH-POS pkt) BLK-DATA-START)
  172.         (at-split-key-pos? blk (MATCH-POS opkt)))
  173. ;;       (fprintf diagout "CHAIN-SCAN: Udelete(blk %d)\\n" (BLK-ID blk))
  174.        (let ((key-len (recon-this-key blk (MATCH-POS opkt) ; delete data
  175.                        key-str 0 256)))
  176.          (substring-move! key-str 0 key-len blk (+ BLK-DATA-START 2))
  177.          (SET-FIELD-LEN! blk (+ BLK-DATA-START 1) key-len)
  178.          (BLK-SET-END! blk (+ BLK-DATA-START 2 key-len)))
  179.        (SET-SKEY-COUNT! respkt (+ (SKEY-COUNT respkt) 1)) ; estimate only!
  180.        (set! rem-ct (+ 1 rem-ct))
  181.        (ENT-SET-DTY! ent #t)
  182.        (SET-MATCH-POS! opkt BLK-DATA-START))
  183.       (else                ; else scan/delete/modify a subrange
  184.        (let ((oldct (SKEY-COUNT respkt))
  185.          (ckstr (make-string 256))
  186.          (clen #f))
  187.          (if func
  188.          (set! clen (recon-this-key blk (MATCH-POS pkt) ckstr 0 256)))
  189.          (SET-MATCH-TYPE! pkt MATCH)  ; by definition
  190.          (set! result
  191.            (scan-loop (ENT-BLK ent) operation pkt opkt func long-tab respkt
  192.                   ckstr clen vstr (SEG-BSIZ (ENT-SEG ent))))
  193.          (if (and (not (eq? operation COUNT-SCAN))
  194.               (> (SKEY-COUNT respkt) oldct))
  195.          (ENT-SET-DTY! ent #t)))
  196.        ))
  197.                     ; delete blk if empty
  198.     (if (and (eq? operation REM-SCAN)
  199.          (BLK-EMPTY? blk)
  200.          (not (END-OF-CHAIN? blk)))
  201.     (blk-delete ent)
  202.     (if (ENT-DTY? ent)
  203.         (if (or (and (eq? operation REM-SCAN)
  204.              (or (WCB-SAR? wcb)
  205.                  (> (BLK-LEVEL blk) LEAF)))
  206.             (and (eq? operation MODIFY-SCAN) (WCB-SAP? wcb)))
  207.         (ent-write ent))))
  208.                     ;further scanning needed?
  209.     (cond ((not (= result SUCCESS))
  210.        (SET-SKEY-LEN! respkt (recon-this-key blk (MATCH-POS pkt)
  211.                         key-str 0 256))
  212. ;;       (fprintf diagout "CHAIN-SCAN: returning result %d\\n" result)
  213.        result)
  214.       ((and (eq? (MATCH-TYPE opkt) PASTEND)
  215.         (not (END-OF-CHAIN? blk)))
  216.        (SET-SKEY-LEN! respkt (recon-this-key blk (MATCH-POS pkt)
  217.                         key-str 0 256))
  218. ;;      (fprintf diagout "CHAIN-SCAN: new starting key len=%d\\n" (SKEY-LEN respkt))
  219.        NOTPRES)
  220.       (else
  221.        (SET-SKEY-LEN! respkt 0)
  222.        SUCCESS)) ))
  223.     
  224. ;; SCAN-LOOP returns SUCCESS if it reaches the end of the range,
  225. ;; else an ERROR code if terminated before that point, either
  226. ;; by an error or by FUNC returning TERMINATED.
  227. ;; SCAN-LOOP returns a value>0 to signal the case of
  228. ;; a MODIFY that requires a block-split. That value is the
  229. ;; length of the new value (which must be >0 to have caused an
  230. ;; increase in block size). SCAN-LOOP NEVER returns NOTPRES.
  231. ;; Note that (MATCH-POS pkt) is always the current scan point.
  232.  
  233. (define (scan-loop blk operation pkt opkt func long-tab respkt
  234.            ckstr clen vstr blksize)
  235.   ;;  (fprintf diagout "SCAN-LOOP called: blk %d pos %d\\n" (blk-id blk) (MATCH-POS pkt))
  236.   (if (> (MATCH-POS opkt) (MATCH-POS pkt))
  237.       (let ((old-bend (BLK-END blk))
  238.         (next-pos (NEXT-CNVPAIR blk (MATCH-POS pkt)))
  239.         (result SUCCESS))
  240.     (if func
  241.         (let* ((vpos (next-field blk (+ 1 (MATCH-POS pkt))))
  242.            (vlen (FIELD-LEN blk vpos)))
  243.           (substring-move! blk (+ vpos 1) (+ vpos vlen 1) vstr 0)
  244.           (set! result (func ckstr clen vstr vlen long-tab))))
  245.     (cond ((>= result SUCCESS)    ; ie, if (= result SUCCESS)
  246.            (cond ((eq? operation REM-SCAN)
  247.               (blk-remove-key-and-val blk (MATCH-POS pkt) blksize)
  248.               (SET-SKEY-COUNT! respkt (+ (SKEY-COUNT respkt) 1))
  249.               (set! rem-ct (+ 1 rem-ct))
  250.               (cond
  251.                ((= (MATCH-POS opkt) next-pos)     
  252.             (SET-MATCH-POS! opkt (MATCH-POS pkt)))
  253.                (else     
  254.             (SET-MATCH-POS! opkt (- (MATCH-POS opkt)
  255.                         (- old-bend (BLK-END blk))))))
  256.               (set! next-pos (MATCH-POS pkt)))
  257.              ((eq? operation COUNT-SCAN)
  258.               (SET-SKEY-COUNT! respkt (+ (SKEY-COUNT respkt) 1))
  259.               (SET-MATCH-POS! pkt next-pos))
  260.              ((change-existing-value blk (MATCH-POS pkt)
  261.                          ckstr clen vstr result blksize)
  262.               (SET-SKEY-COUNT! respkt (+ (SKEY-COUNT respkt) 1))
  263.               (set! next-pos (- next-pos (- old-bend (BLK-END blk))))
  264.               (SET-MATCH-POS! opkt (- (MATCH-POS opkt)
  265.                           (- old-bend (BLK-END blk))))
  266.               (SET-MATCH-POS! pkt next-pos)
  267.               (set! result SUCCESS))
  268.              (else
  269.               (fprintf diagout "ScAN-LOOP: hit modify special case\\n"))
  270.              ))
  271.           ((= result NOTPRES)       ; not deleting, just advance scan ptr
  272.            (SET-MATCH-POS! pkt next-pos)
  273.            ))
  274.     (cond ((or (= result SUCCESS) (= result NOTPRES))
  275.            (cond (func        ; update key to pass to FUNC
  276.               (set! clen (+ (field-len blk next-pos)
  277.                     (field-len blk (+ 1 next-pos))))
  278.               (substring-move! blk (+ next-pos 2)
  279.                        (+ next-pos 2 (field-len blk (+ 1 next-pos)))
  280.                        ckstr (field-len blk next-pos))
  281.               ))
  282.            (scan-loop blk operation pkt opkt func long-tab respkt
  283.               ckstr clen vstr blksize))
  284.           (else result)))
  285.       SUCCESS))
  286.